/* JREAD.PL : Reading a term from a list of tokens. */


/* IMPORT */

:- ext(infixop,4,'$infop').
:- ext(postfixop,3,'$posop').
:- ext(prefixop,3,'$preop').
:- ext(stripvars,2,'$strip').
:- ext(syntaxerror,1,'$syner').
:- ext(tidemark,1,'$tidem').
:- ext(tidemark1,1,'$tide1').
:- ext(tokens,2,'$toke2').


/* EXPORT */

:- ext(metaread,1,'$mrd1').
:- ext(metaread,2,'$mrd2').
:- ext(read,2,'$read2').

:- entry(metaread,1).
:- entry(metaread,2).
:- entry(read,2).

:- entry(read,1).


/* VARIABLES */

:- ext('$HWM').

:- meta is static.


/* MODES */

:- mode read(?).
:- mode read(?,?).
:- mode metaread(?).
:- mode metaread(?,?).
:- mode mark(+,-).
:- mode expr(+,+,+,-,?).
:- mode afterprefixop(+,+,+,+,+,-,?).
:- mode exprtl0(+,+,+,-,?).
:- mode exprtl(+,+,+,+,+).
:- mode exprlisttl(+,+,-,-).
:- mode listexprtl(+,+,-,-).
:- mode peepop(+,-).
:- mode connects(+,?,?).
:- mode construct(?,?,-).
:- mode conslist(?,?,-).
:- mode conspair(?,?,-).
:- mode consdisjunct(?,?,-).
:- mode decompose(+,-).



/*===========================================================================*/

/* Meaning of arguments :

	expr(+Token0,+String0,+Precedence1,-Term1,?String1)

	exprtl0(+String0,+Term0,+Precedence1,-Term1,?String1)

	exprtl(+String0,+Precedence0,+Term0,+Precedence1,[-Term1|?String1])

	exprlisttl(+Token0,+String0,-Termlist1,-String1)

	listexprtl(+Token0,+String0,-Listterm1,-String1)

*/


:-fastcode.


read(X):-read(X,D).

metaread(X) :- metaread(X,←).

read(X,D):-
   wd(meta) := 0,
   read←in(X1,D),
   X1=X.

metaread(X,L):-
   wd(meta) := 1,
   read←in(X,D),
   stripvars(D,L0), mark(L0,L).

mark([var(←,X,Type)|D],[X|L]) :-
   X='#VAR'(Type,←,←,←),
   (Type=single; Type=multiple),!,
   mark(D,L).
mark([],[]).

read←in(X,D) :-
   repeat,
      tokens([W1|S1],D),
      wd('$HWM'):=100000,
    ( expr(W1,S1,(1,1200),X,[]); syntaxerror([W1|S1]),fail ),
   !.

expr(var(X,←),S0,N,Y,S) :-!, exprtl0(S0,X,N,Y,S).
expr(atom(F),['('|S2],N,Y,S) :-!,
   connects(S2,W3,S3), expr(W3,S3,(0,999),X1,S4),
   connects(S4,W5,S5), exprlisttl(W5,S5,A,S6), !,
   construct(F,[X1|A],X),
   exprtl0(S6,X,N,Y,S).
expr(atom(-),[xwd(X1,X2)|S2],N,Y,S) :-!,
   Temp is local,
   wd(Temp) := -xwd(X1,X2),
  (if 0 >= wd(Temp), wd(Temp) >= -131072 then
      X iq wd(Temp), exprtl0(S2,X,L,Y,S)
   else
      Y1 is lh(Temp),
      Y2 is rh(Temp),
      exprtl0(S2,xwd(Y1,Y2),N,Y,S)
  ).
expr(atom(F),S1,N,Y,S) :-!,
 ( prefixop(F,M,M1), !,
      afterprefixkp(F,M,M1,S1,N,Y,S);
   exprtl0(S1,F,N,Y,S) ).
expr(xwd(0,X),S1,N,Y,S) :- X>=0,!, exprtl0(S1,X,N,Y,S).
expr(xwd(X1,X2),S1,N,Y,S) :-!, exprtl0(S1,xwd(X1,X2),N,Y,S).
expr('[',[']'|S2],N,Y,S) :-!, exprtl0(S2,[],N,Y,S).
expr('[',[W2|S2],N,Y,S) :-!, 
   expr(W2,S2,(0,999),X1,S3),
   connects(S3,W4,S4), listexprtl(W4,S4,A,S5), !,
   conslist(X1,A,List),
   exprtl0(S5,List,N,Y,S).
expr('(',[W2|S2],N,Y,S) :-!, 
   expr(W2,S2,(1,1200),X,[')'|S3]), !,
   exprtl0(S3,X,N,Y,S).
expr(' (',[W2|S2],N,Y,S) :-!, 
   expr(W2,S2,(1,1200),X,[')'|S3]), !,
   exprtl0(S3,X,N,Y,S).
expr('{',['⎇'|S2],N,Y,S) :-!, exprtl0(S2,{⎇,N,Y,S).
expr('{',[W2|S2],N,Y,S) :-!, 
   expr(W2,S2,(1,1200),X,['⎇'|S3]), !,
   construct({⎇,[X],Curly),
   exprtl0(S3,Curly,N,Y,S).
expr(string(X),S1,N,Y,S) :-!, decompose(X,X1), exprtl0(S1,X1,N,Y,S).
expr(W1,S1,←,←,←) :- tidemark1(S1).

afterprefixop(F,M,M1,S0,(N0,N),Y,S) :- M=<N, !,
 ( peepop(S0,S1),
      exprtl(S1,M,F,(N0,N),[Y|S]);
   connects(S0,W1,S1), M10 is M1/1000,
      expr(W1,S1,(M10,M1),X1,S2),
      exprtl(S2,M,X,(N0,N),[Y|S]),
      construct(F,[X1],X) ).
afterprefixop(←,←,←,S0,←,←,←) :- tidemark(S0).

exprtl0([atom(F)|S1],X1,(N0,N),Y,S) :-!,
 ( infixop(F,M1,M,M2),
     (if M=<N then
         connects(S1,W2,S2), M20 is M2/1000,
         expr(W2,S2,(M20,M2),X2,S3),
         exprtl(S3,M,X,(N0,N),[Y|S]),
         construct(F,[X1,X2],X)
      else Y=X1, S=infixop(F,M1,M,M2,S1) );
   postfixop(F,M1,E),
     (if M=<N then
         peepop(S1,S2),
         exprtl(S2,M,X,(N0,N),[Y|S]),
         construct(F,[X1],X)
      else Y=X1, S=postfixop(F,M1,M,S1) );
   tidemark1(S1) ).
exprtl0([','|S1],X1,(1,N),Y,S) :- !,
   connects(S1,W2,S2), expr(W2,S2,(1,1000),X2,S3),
   conspair(X1,X2,Pair),
   exprtl(S3,1000,Pair,(1,N),[Y|S]).
exprtl0(['|'|S1],X1,(1,N),Y,S) :- 1100 =< N, !,
   connects(S1,W2,S2), expr(W2,S2,(1,1100),X2,S3),
   consdisjunct(X1,X2,Disjunct),
   exprtl(S3,1100,Disjunct,(1,N),[Y|S]).
exprtl0(S0,X,←,X,S0):-!.
exprtl0(S0,←,←,←,←) :- tidemark(S0).

exprtl(infixop(F,M1,M,M2,S1),L,X1,(N0,N),S) :- M=<N, !, L=<M1,
   connects(S1,W2,S2), M20 is M2/1000,
   expr(W2,S2,(M20,M2),X2,S3),
   exprtl(S3,M,X,(N0,N),S),
   construct(F,[X1,X2],X).
exprtl(postfixop(F,M1,M,S1),L,X1,(N0,N),S) :- M=<N, !, L=<M1,
   peepop(S1,S2),
   exprtl(S2,M,X,(N0,N),S),
   construct(F,[X1],X).
exprtl([','|S1],L,X1,(1,N),S) :- !,
   coNnects(S1,W2,S2), expr(W2,S2,(1,1000),X2,S3),
   conspair(X1,X2,Pair),
   exprtl(S3,1000,Pair,(1,N),S).
exprtl(['|'|S1],L,X1,(1,N),S) :- 1100 =< N, !, L=<1099,
   connects(S1,W2,S2), expr(W2,S2,(1,1100),X2,S3),
   consdisjunct(X1,X2,Disjunct),
   exprtl(S3,1100,Disjunct,(1,N),S).
exprtl(S0,←,X,←,[X|S0]):-!.
exprtl(S0,←,←,←,←) :- tidemark(S0).

exprlisttl(',',[W2|S2],[X|A],S) :-!,
   expr(W2,S2,(0,999),X,S3),
   connects(S3,W4,S4), exprlisttl(W4,S4,A,S).
exprlisttl(')',S1,[],S1) :-!.
exprlisttl(W1,S1,←,←) :- tidemark1(S1).

listexprtl(',',[atom('..')|S2],X,S) :-!,
   connects(S2,W3,S3), expr(W3,S3,(0,999),X,[']'|S]).
listexprtl(',',[W2|S2],List,S) :-!,
   expr(W2,S2,(0,999),X,S3),
   connects(S3,W4,S4), listexprtl(W4,S4,A,S),
   conslist(X,A,List).
listexprtl('|',[W2|S2],X,S) :-!,
   expr(W2,S2,(0,999),X,[']'|S]).
listexprtl(']',S1,[],S1):-!.
listexprtl(W1,S1,←,←) :- tidemark1(S1).

peepop([atom(F)|S1],infixop(F,M1,M,M2,S1)) :- infixop(F,M1,M,M2).
peepop([atom(F)|S1],postfixop(F,M1,M,S1)) :- postfixop(F,M1,M).
peepop(S0,S0).

connects([W|S],W,S).
connects([],←,←) :- tidemark([]).

construct(F,A,X) :- wd(meta)=:=0, !, X=..[F|A].
construct(F,A,F!A).

conslist(X,A,[X|A]) :- wd(meta)=:=0, !.
conslist(X,A,'.'![X,A]).

conspair(X1,X2,(X1,X2)) :- wd(meta)=:=0, !.
conspair(X1,X2,','![X1,X2]).

consdisjunct(X1,X2,(X1;X2)) :- wd(meta)=:=0, !.
consdisjunct(X1,X2,';'![X1,X2]).

decompose(X,X) :- wd(meta)=:=0, !.
decompose([X|L],'.'![X,L1]) :- decompose(L,L1).
decompose([],[]).